home *** CD-ROM | disk | FTP | other *** search
/ Especial Multimedia / Especial Multimedia.iso / Multimed / Prg / KALENDAR.ZIP / KALENDAR.BAS < prev    next >
BASIC Source File  |  1997-09-14  |  9KB  |  237 lines
  1. Option Explicit
  2.  
  3. ' Drawing states for Kalendar_DrawDay
  4. Global Const KAL_STATE_NOT_SELECTED = 0         ' Day not selected
  5. Global Const KAL_STATE_SELECTED_WITH = 1        ' Day selected, Kalendar has focus
  6. Global Const KAL_STATE_SELECTED_WITHOUT = 2     ' Day selected, Kalendar does not have focus
  7. Global Const KAL_STATE_OTHERMONTH = 3           ' Day is not from this month.
  8.  
  9. ' Kalendar printing options
  10. Global Const KAL_PRINT_PORTRAIT = 1             ' Print Kalendar full page in portrait mode.
  11. Global Const KAL_PRINT_LANDSCAPE = 2            ' Print Kalendar landscape full page
  12. Global Const KAL_PRINT_USER = 3                 ' Print Kalendar as specified by user.
  13.  
  14. ' KalendarDrawBitmap bitmap alignments
  15. Global Const KAL_DBM_UL = 0              ' Draw bitmap in upper left of daybox.
  16. Global Const KAL_DBM_UC = 1              ' Draw bitmap in upper center of daybox.
  17. Global Const KAL_DBM_UR = 2              ' Draw bitmap in upper right of daybox.
  18. Global Const KAL_DBM_CL = 3              ' Draw bitmap in center left of daybox.
  19. Global Const KAL_DBM_CC = 4              ' Draw bitmap in center center of daybox.
  20. Global Const KAL_DBM_CR = 5              ' Draw bitmap in center right of daybox.
  21. Global Const KAL_DBM_LL = 6              ' Draw bitmap in lower left of daybox.
  22. Global Const KAL_DBM_LC = 7              ' Draw bitmap in lower center of daybox.
  23. Global Const KAL_DBM_LR = 8              ' Draw bitmap in lower right of daybox.
  24.  
  25.  
  26. ' KalDrawBitmap
  27. '
  28. ' Draws a bitmap from a picture control onto a day box.
  29. '
  30. ' Parameters:
  31. '   hdc - hdc to draw on (usu. from DrawDay or DrawOnDay parameter)
  32. '   Pict - picture control that contains the bitmap the draw.
  33. '          NOTES: Pict.AutoDraw must be true.
  34. '                 The size of the control should match the size of the bitmap (set Pict.AutoSize to true)
  35. '                 You may want to turn off the border.
  36. '   x, y, x2, y2 - The size of the day box ( from DrawDay or DrawOnDay parameters)
  37. '   Position     - One of the KAL_DBM_ constants
  38. '   dwROp        - Bitwise operation to use to draw the bitmap. See the SRC constants in the
  39. '                  Win31API.Txt file, provided with VB, for the various values.
  40. Sub KalDrawBitmap (hDC As Integer, Pict As Control, x As Single, y As Single, x2 As Single, y2 As Single, Position As Integer, dwROp As Long)
  41. Dim retval As Integer
  42. Dim R As Rect
  43. Dim W As Long, H As Long
  44.  
  45. Dim pixPictWidth As Integer
  46. Dim pixPictHeight As Integer
  47.  
  48.     KalWindowAPIRect x, y, x2, y2, R
  49.     InflateRect R, -1, -1
  50.  
  51.     ' Save the pictures height and width as pixels
  52.     pixPictWidth = Pict.Width / Screen.TwipsPerPixelY
  53.     pixPictHeight = Pict.Height / Screen.TwipsPerPixelY
  54.  
  55.     Select Case Position
  56.     Case 0                  ' Upper left
  57.     Case 1                  ' Upper center
  58.         R.left = R.left + ((R.right - R.left + 1) - pixPictWidth) / 2
  59.         
  60.     Case 2                  ' Upper right
  61.         R.left = R.right - pixPictWidth + 1
  62.  
  63.     Case 3                  ' Center left
  64.         R.top = R.top + ((R.bottom - R.top + 1) - pixPictHeight) / 2
  65.     Case 4                  ' Center center
  66.         R.left = R.left + ((R.right - R.left + 1) - pixPictWidth) / 2
  67.         R.top = R.top + ((R.bottom - R.top + 1) - pixPictHeight) / 2
  68.     Case 5                  ' Center right
  69.         R.top = R.top + ((R.bottom - R.top + 1) - pixPictHeight) / 2
  70.         R.left = R.right - pixPictWidth + 1
  71.     Case 6                  ' Lower left
  72.         R.top = R.bottom - pixPictHeight + 1
  73.     Case 7                  ' Lower center
  74.         R.top = R.bottom - pixPictHeight + 1
  75.         R.left = R.left + ((R.right - R.left + 1) - pixPictWidth) / 2
  76.     Case 8                  ' Lower right
  77.         R.top = R.bottom - pixPictHeight + 1
  78.         R.left = R.right - pixPictWidth + 1
  79.     End Select
  80.     
  81.     W = pixPictWidth
  82.     If W > R.right - R.left + 1 Then
  83.     W = R.right - R.left + 1
  84.     End If
  85.  
  86.     H = pixPictHeight
  87.     If H > R.bottom - R.top + 1 Then
  88.     H = R.bottom - R.top + 1
  89.     End If
  90.  
  91.     retval = BitBlt(hDC, R.left, R.top, W, H, Pict.hDC, 0, 0, dwROp)
  92. End Sub
  93.  
  94. ' KalDrawDay
  95. '
  96. ' Sample code to draw the entire day box. It only draws the day number in the upper left corner
  97. ' of the day box.
  98. '
  99. ' Parameters:
  100. '   Kal - The Kalendar being drawn on
  101. '   hDC - hDC from the DrawDay or DrawOnDay call.
  102. '   State - the State from the DrawDay or DrawOn Day call
  103. '   theDay - theDay from the DrawDay or DrawOn Day call
  104. '   x, y, x2, y2 - coordinate parameters form the DrawDay or DrawOnDay call
  105. Sub KalDrawDay (Kal As Control, hDC As Integer, STATE As Integer, theDay As Long, x As Single, y As Single, x2 As Single, y2 As Single)
  106. Dim tmpx As Integer
  107. Dim oldPen As Integer
  108. Dim txtDay As String
  109. Dim R As Rect
  110. Dim oldBrush
  111. Dim oldColor, oldTextColor
  112. Dim lx As Long
  113. Dim StrTmp As String
  114.  
  115. Dim linePen As Integer
  116. Dim OldFont As Integer, theFont As Integer
  117.  
  118.     txtDay = Format(theDay, "d")
  119.  
  120.     KalWindowAPIRect x, y, x2, y2, R
  121.  
  122.     linePen = CreatePen(PS_SOLID, 1, Kal.LineColor)
  123.     theFont = KalMakeFont(hDC, Kal)
  124.  
  125.     oldPen = SelectObject(hDC, linePen)
  126.     OldFont = SelectObject(hDC, theFont)
  127.  
  128.     Select Case STATE
  129.     Case KAL_STATE_SELECTED_WITHOUT
  130.         oldBrush = SelectObject(hDC, GetStockObject(LTGRAY_BRUSH))
  131.         oldColor = SetBkColor(hDC, RGB(192, 192, 192))
  132.         oldTextColor = SetTextColor(hDC, 0)
  133.     Case KAL_STATE_SELECTED_WITH
  134.         oldBrush = SelectObject(hDC, GetStockObject(LTGRAY_BRUSH))
  135.         oldColor = SetBkColor(hDC, RGB(192, 192, 192))
  136.         oldTextColor = SetTextColor(hDC, RGB(255, 0, 0))
  137.     Case KAL_STATE_NOT_SELECTED
  138.         oldBrush = SelectObject(hDC, GetStockObject(WHITE_BRUSH))
  139.         oldColor = SetBkColor(hDC, RGB(255, 255, 255))
  140.         oldTextColor = SetTextColor(hDC, 0)
  141.     Case KAL_STATE_OTHERMONTH
  142.         oldBrush = SelectObject(hDC, GetStockObject(LTGRAY_BRUSH))
  143.         oldColor = SetBkColor(hDC, RGB(192, 192, 192))
  144.         oldTextColor = SetTextColor(hDC, RGB(255, 255, 255))
  145.     End Select
  146.     
  147.     tmpX = Rectangle(hDC, R.left, R.top, R.right, R.bottom)
  148.     
  149.     ' Draw the day number
  150.     InflateRect R, -1, -1
  151.     tmpX = DrawText(hDC, txtDay, Len(txtDay), R, DT_LEFT Or DT_SINGLELINE)
  152.  
  153.     tmpX = SelectObject(hDC, oldPen)
  154.     tmpX = SelectObject(hDC, OldFont)
  155.     tmpX = DeleteObject(linePen)
  156.     tmpX = DeleteObject(theFont)
  157.  
  158.     tmpX = SelectObject(hDC, oldBrush)
  159.     lx = SetBkColor(hDC, oldColor)
  160.     lx = SetTextColor(hDC, oldTextColor)
  161. End Sub
  162.  
  163. ' KalDrawText
  164. '
  165. ' Draws text in a day box.
  166. '
  167. ' Parameters:
  168. '   hdc - hdc from DrawDay or DrawOnDay call.
  169. '   theDay - theDay from DrawDay or DrawOnDay call.
  170. '   R - the rectangle in which the text will be drawn.
  171. '   txt$ - the string to be drawn
  172. '   ctlFont - a control that is set up with the font and forecolor that the text is to be drawn in.
  173. '   MultiLine - True to draw text with word-wrap.
  174. Sub KalDrawText (hDC As Integer, theDay As Long, R As Rect, ByVal txt$, ctlFont As Control, MultiLine As Integer)
  175. Dim retval As Integer
  176. Dim oldTextColor As Long
  177. Dim lx As Long
  178. Dim oldBkMode As Integer
  179. Dim OldFont As Integer
  180. Dim HFont As Integer
  181.  
  182.     If Len(txt) > 0 Then
  183.     
  184.     '--- Set up the drawing information
  185.     oldBkMode = setBkMode(hDC, TRANSPARENT)
  186.     oldTextColor = SetTextColor(hDC, ctlFont.ForeColor)
  187.     
  188.     HFont = KalMakeFont(hDC, ctlFont)
  189.     OldFont = SelectObject(hDC, HFont)
  190.     
  191.     retval = DrawText(hDC, txt, Len(txt), R, DT_LEFT Or IIf(MultiLine, DT_WORDBREAK, 0))
  192.     
  193.     ' Clean up after myself.
  194.     retval = SelectObject(hDC, OldFont)
  195.     retval = DeleteObject(HFont)
  196.     
  197.     '--- Restore the old drawing information
  198.     oldBkMode = setBkMode(hDC, oldBkMode)
  199.     lx = SetTextColor(hDC, oldTextColor)
  200.     End If
  201. End Sub
  202.  
  203. ' KalMakeFont
  204. '
  205. ' This function creates a font that is described by the font properties of a control.
  206. '
  207. ' Parameters:
  208. '   hDC - hdc parameter from DrawDay or DrawOnDay
  209. '   Ctl - the control that has the font information
  210. Function KalMakeFont (hDC As Integer, Ctl As Control) As Integer
  211. Dim FWBold As Integer
  212.  
  213.     If Ctl.FontBold Then
  214.     FWBold = FW_BOLD
  215.     Else
  216.     FWBold = FW_NORMAL
  217.     End If
  218.  
  219.     KalMakeFont = CreateFont(-(Ctl.FontSize * GetDeviceCaps(hDC, LOGPIXELSY) / 72), 0, 0, 0, FWBold, Ctl.FontItalic, Ctl.FontUnderline, Ctl.FontStrikethru, 0, 0, 0, 0, DEFAULT_PITCH Or FF_DONTCARE, Ctl.FontName)
  220.  
  221. End Function
  222.  
  223. ' KalWindowAPIRect
  224. '
  225. ' Converts rectangular twip coordinates into a Windows API Rectangle Structure
  226. '
  227. ' Parameters
  228. '   x, y, x2, y2 - parameters from the DrawDay or DrawOnDay call.
  229. '   rct - rectangle structure to hold converted coordinates.
  230. Sub KalWindowAPIRect (x As Single, y As Single, x2 As Single, y2 As Single, rct As Rect)
  231.     rct.left = x / Screen.TwipsPerPixelX
  232.     rct.top = y / Screen.TwipsPerPixelY
  233.     rct.right = x2 / Screen.TwipsPerPixelX
  234.     rct.bottom = y2 / Screen.TwipsPerPixelY
  235. End Sub
  236.  
  237.